POINT Software Programming/PPROG1.ISO/pascal/swag/datetime.swg/0038_Clock & Timer Unit.pas

Pascal/Delphi Source File | 1994-02-03 | 19.0 KB | 526 lines

UNIT Clocks;

 {This UNIT provides a CLOCK OBJECT for use in Turbo Pascal 5.5.

  (C) Copyright 1989, Earl F. Glynn, Overland Park, KS.  Compuserve 73257,3527.
  All Rights Reserved.  This Turbo Pascal 5.5 UNIT may be freely distributed
  for non-commerical use.

  Clock objects can be used as individual timers, using either the CMOS
  real-time clock, or the DOS real-time clock.  As shown in the ClkDemo
  PROGRAM, the DOS clock can be shut off when interrupts are disabled.
  The resolution of the CMOS clock is only 1 second, while the DOS clock
  has 0.0549 second resolution (18.203 ticks per second).  In addition
  to real-time clocks, static time stamps can be manipulated and
  formatted.  The range for all clocks and time stamps is Jan 1, 1900
  through Jun 5, 2079.  (Sep 18, 1989 is the midpoint of this range).

  Several REXX-like FUNCTIONs provide Date/Time formatting.  [REXX,
  the Restructured Extended Executor, or sometimes called the System Product
  Interpreter, is IBM's SAA command language (now primarily for VM/CMS).
  That is, REXX EXECs are CMS's equivalent of PC .BAT files but REXX
  provides much more functionality than the PC 'BAT' language.]

  REXX-like FUNCTIONS in Pascal could be considered an oxymoron since
  REXX doesn't have any concept of TYPEd variables and obviously Pascal does.
  The Pascal functions in most cases were written to return STRINGs,
  which is similar to REXX.  In some cases, where a number was returned
  that could be used in calculations, a separate function was used.  For
  example, the REXX TIME('Elapsed') function was implemented as an object
  'Elapsed' method that returns a REAL value to be used in calculations.
  A function 'hhmmss' can be used to format elapsed seconds in a
  character string, if desired.

  See the CLKDEMO.PAS, FLOPS.PAS and TIMER.PAS programs for sample usage
  of clock objects and this UNIT.}

INTERFACE

  TYPE
    ClockValue    =
      RECORD
        year      :  1900..2079;
        month     :  1..12;
        day       :  1..31;
        hour      :  0..23;
        minute    :  0..59;
        second    :  0..59;
        hundredth :  0..99;
      END;
    ClockType     =  (CMOSClock,DOSClock);
    Clock         =
      OBJECT
        mode      :  ClockType;
        StartValue:  ClockValue;
        FUNCTION  Date(s:  STRING):  STRING;
        FUNCTION  Elapsed:  REAL;   {elapsed timer (seconds)}
        PROCEDURE Start (ct:  ClockType);
        FUNCTION  Time(s:  STRING):  STRING;
      END;

  FUNCTION  DateFormat(s:  STRING; clk:  ClockValue):  STRING;
  FUNCTION  DaysThisCentury(y, m, d:  WORD):  WORD;
  FUNCTION  hhmmss(seconds:  REAL):  STRING;
  FUNCTION  JulianDate(y{1900..}, m{1..12}, d{1..31}:  WORD):  WORD;
  PROCEDURE SetClock (yr,mo,d,h,m,s,hth:  WORD; VAR t:  ClockValue);
  FUNCTION  TimeDiff(t2,t1:  ClockValue):  REAL;  {t2 - t1 seconds}
  FUNCTION  TimeFormat(s:  STRING; clk:  ClockValue):  STRING;
  PROCEDURE UnPackTime (TurboTime:  LongInt; VAR Clk:  ClockValue);

IMPLEMENTATION

  USES
    DOS; {INTR}

  VAR
    c  :  CHAR;

  FUNCTION L2C(L:  LONGINT):  STRING;  {LONGINT-to-character}
    {L2C and W2C are intended to be similar to the standard D2C
     (decimal-to-character) REXX function.}
    VAR t:  STRING[11];
  BEGIN
    STR (L,t);
    L2C := t
  END {L2C};

  FUNCTION W2C(w:  WORD):  STRING;     {word-to-character}
    VAR t:  STRING[5];
  BEGIN
    STR (w,t);
    W2C := t
  END {W2C};

  FUNCTION TwoDigits (w:  WORD):  STRING;
    CONST Digit:  ARRAY[0..9] OF CHAR = '0123456789';
  BEGIN
    w := w MOD 100;  {just to be safe}
    TwoDigits := Digit[w DIV 10] + Digit[w MOD 10]
  END {TwoDigits};

  FUNCTION DateFormat(s:  STRING; clk:  ClockValue):  STRING;
    CONST
      days  :  ARRAY[0..6] OF STRING[9]
                         =('Sunday','Monday','Tuesday','Wednesday',
                           'Thursday','Friday','Saturday');
      months:  ARRAY[1..12] OF STRING[9]
                         =('January','February','March',
                           'April',  'May',     'June',
                           'July',   'August',  'September',
                           'October','November','December');
  BEGIN
    IF   LENGTH(s) = 0
    THEN c := 'N' {NORMAL}
    ELSE c := UpCase(s[1]);
    CASE c OF
            {Normal (default):  dd Mmm yyyy -- no leading zero or blank}
      'N':  DateFormat := W2C(clk.day) + ' ' + COPY(months[clk.month],1,3)
                                       + ' ' + W2C(clk.year);

            {Century:  ddddd -- no leading zeros or blanks}
      'C':  DateFormat := W2C( DaysThisCentury(clk.year,clk.month,clk.day) );

            {Julian date:  ddd -- no leading 0s or blanks}
      'D':  DateFormat := W2C(JulianDate(clk.year,clk.month,clk.day));

            {European:  dd/mm/yy}
      'E':  DateFormat := TwoDigits(clk.day  )  + '/' +
              TwoDigits(clk.month)  + '/' + TwoDigits(clk.year MOD 100);

            {Month:  current month name in mixed case}
      'M':  DateFormat := months[clk.month];

            {Ordered:  yy/mm/dd suitable for sorting}
      'O':  DateFormat := TwoDigits(clk.year MOD 100)  + '/' +
              TwoDigits(clk.month)  + '/' + TwoDigits(clk.day);

            {Standard:  yyyymmdd -- suitable for sorting (ISO/R 2014-1971)}
      'S':  DateFormat := W2C(clk.year) + TwoDigits(clk.month) +
              TwoDigits(clk.day);

            {USA:  mm/dd/yy}
      'U':  DateFormat := TwoDigits(clk.month)  + '/' +
              TwoDigits(clk.day  )  + '/' + TwoDigits(clk.year MOD 100);

            {Weekday:  returns day of the week in mixed case}
      'W':  DateFormat :=  {January 1, 1900 was a Monday}
              days[DaysThisCentury(clk.year,clk.month,clk.day) MOD 7 ]

      ELSE DateFormat := ''
    END
  END {DateFormat};

  FUNCTION DaysThisCentury(y, m, d:  WORD):  WORD;

  {This function was written to be equivalent to the REXX language
   DATE('Century') function.  See DateFormat FUNCTION in this UNIT.

   Jan 1, 1900 = 1, Jan 2, 1900 = 2, ..., Jun 5, 2079 = 65535 (largest word).
   Jan 1, 1989 = 32508, Jan 1, 1990 = 32873, Sep 18, 1989 = 32768.

   "The Astronomical Almanac" defines the astronomical julian date
   to be the numbers of mean solar days since 4713 BC.  In this system
   Jan 1, 1900 = 2415020.5, Jan 1, 2000 = 2451544.5,
   Jan 1, 1989 = 2447527.5, Jan 1, 1990 = 2447892.5,
   Jun 5, 2079 = 2480554.5.  This data was used to validate the function.

   (Note:  DaysThisCentry(y,m,d) MOD 7  returns day-of-week index, i.e.,
   0=Sunday, 1=Monday, etc. since January 1, 1900 was a Monday.)}
  BEGIN
    DaysThisCentury := 365*(y-1900) + INTEGER(y-1901) DIV 4 + JulianDate(y,m,d)
  END {DaysThisCentury};

  FUNCTION  hhmmss(seconds:  REAL):  STRING;
    {Convert elapsed times/time differences to [hh:]mm:ss format}
    VAR
      h,h1,h2:  LONGINT;
      s      :  STRING;
      t      :  LONGINT;
  BEGIN
    IF   seconds < 0.0
    THEN BEGIN
      seconds := ABS(seconds);
      s := '-'
    END
    ELSE s:= '';
    h1 := 0;
    WHILE seconds > 2147483647.0 DO BEGIN  {fixup real-to-LONGINT problem}
      seconds := seconds - 1576800000.0;   {subtract about 50 years}
      h1 := h1 + 438000 {hours}            {add about 50 years}
    END;
    t := TRUNC(seconds);
    h2 := t DIV 3600;  {hours}
    h := h1 + h2;
    IF   h > 0
    THEN s := s + L2C(h) + ':';
    t := t - h2*3600;  {minutes and seconds left}
    hhmmss := s + TwoDigits(t DIV 60) + ':' + TwoDigits(t MOD 60)
  END {hhmmss};

  FUNCTION JulianDate(y{1900..}, m{1..12}, d{1..31}:  WORD):  WORD;
    CONST
      julian:  ARRAY[0..12] OF WORD =
               (0,31,59,90,120,151,181,212,243,273,304,334,365);
    VAR
      jd:  WORD;
  BEGIN
    jd := julian[m-1] + d;
    IF   (m > 2) AND (y MOD 4 = 0) AND
         (y <> 1900) {AND (y <> 2100)}
    THEN INC (jd);   {1900 and 2100 are not leap years; 2000 is}
    JulianDate := jd
  END {JulianDate};

  PROCEDURE SetClock (yr,mo,d,h,m,s,hth:  WORD; VAR t:  ClockValue);
  BEGIN
    t.year      := yr;
    t.month     := mo;
    t.day       := d;
    t.hour      := h;
    t.minute    := m;
    t.second    := s;
    t.hundredth := hth
  END {SetClock};

  FUNCTION  TimeDiff(t2,t1:  ClockValue):  REAL;
  BEGIN  {REAL arithmetic is used to avoid INTEGER/LONGINT overflows}
    TimeDiff :=   0.01*INTEGER(t2.hundredth - t1.hundredth) +
                       INTEGER(t2.second - t1.second      ) +
                  60.0*INTEGER(t2.minute - t1.minute      ) +
                3600.0*INTEGER(t2.hour   - t1.hour        ) +
               86400.0*LONGINT(DaysThisCentury(t2.year,t2.month,t2.day) -
                       LONGINT(DaysThisCentury(t1.year,t1.month,t1.day)))
  END {TimeDiff};

  FUNCTION  TimeFormat(s:  STRING; clk:  ClockValue):  STRING;
    VAR
      meridian:  STRING[2];
  BEGIN
    IF   LENGTH(s) = 0
    THEN c := 'N' {NORMAL}
    ELSE c := UpCase(s[1]);
    CASE c OF

            {Normal (default):  hh:mm:ss}
      'N':  TimeFormat := TwoDigits(clk.hour  )  + ':' +
              TwoDigits(clk.minute)  + ':' + TwoDigits(clk.second);

            {Civil:  hh:mxx, for example:  11:59pm}
      'C':  BEGIN
              IF   clk.hour < 12
              THEN BEGIN
                meridian := 'am';  {anti meridiem}
                IF   clk.hour = 0
                THEN clk.hour := 12;  {12:00am is midnight}
              END                     {12:00pm is noon}
              ELSE BEGIN
                meridian := 'pm';  {post meridiem}
                IF   clk.hour > 12
                THEN clk.hour := clk.hour - 12
              END;
              TimeFormat := W2C(clk.hour)  + ':' +
                TwoDigits(clk.minute)  + meridian
            END;

            {Hours:  hh -- number of hours since midnight}
      'H':  TimeFormat := W2C(clk.hour);

            {Long:  hh.mm:ss.xx (real REXX requires microseconds here)}
      'L':  TimeFormat := TwoDigits(clk.hour  )  + ':' +
              TwoDigits(clk.minute)  + ':' + TwoDigits(clk.second)  + '.' +
              TwoDigits(clk.hundredth);

            {Minutes:  mmmm -- number of minutes since midnight}
      'M':  TimeFormat := W2C(60*clk.hour + clk.minute);

            {Seconds:  sssss -- number of seconds since midnight}
      'S':  TimeFormat := L2C( 3600*LONGINT(clk.hour)
               + 60*LONGINT(clk.minute) + LONGINT(clk.second) )

      ELSE TimeFormat := ''
    END
  END {TimeFormat};

  PROCEDURE UnPackTime (TurboTime:  LongInt; VAR Clk:  ClockValue);
    {The DOS.DateTime TYPE does not have hundredths of a second in its
     definition.  Clocks.UnPackTime allows the use of Clocks.DateFormat
     and Clocks.TimeFormat with time stamps, especially with SearchRec
     TYPEed variables defined by FindFirst/FindNext.}
    VAR
      DT:  DateTime;
  BEGIN
    DOS.UnPackTime (TurboTime, DT);
    SetClock (DT.year,DT.month,DT.day,DT.hour,DT.min,DT.sec,0, Clk)
  END {UnPackTime};

  PROCEDURE GetDateTime (VAR c:  ClockValue; ct:  ClockType);
    VAR r1,r2:  Registers;

    FUNCTION BCD (k:  BYTE):  WORD;    {convert binary-coded decimal}
    BEGIN
      BCD := 10*(k DIV 16) + (k MOD 16)
    END {BCD};

  BEGIN
    CASE ct OF
      CMOSClock:
        BEGIN
          r1.AH := $04;
          INTR ($1A,r1);      {BIOS call:  read date from real-time clock}
          r2.AH := $02;
          Intr ($1A,r2);      {BIOS call:  read real-time clock}
          SetClock (100*BCD(r1.CH) + BCD(r1.CL) {yr},
                    BCD(r1.DH) {mo}, BCD(r1.DL) {day},
                    BCD(r2.CH) {h},  BCD(r2.CL) {m}, BCD(r2.DH) {s},
                    0 {.00}, c)
        END;
      DOSClock:
        BEGIN
          r1.AH := $2A;       {could use GetDate and GetTime from DOS UNIT}
          INTR ($21,r1);      {DOS call:  get system date}
          r2.AH := $2C;
          Intr ($21,r2);      {DOS call:  get system time}
          SetClock (r1.CX,r1.DH,r1.DL, r2.CH,r2.CL,r2.DH,r2.DL, c)
        END
    END
  END {GetDateTime};

  FUNCTION Clock.Date(s:  STRING):  STRING;
  BEGIN
    Date := DateFormat(s,StartValue)
  END {Date};

  FUNCTION  Clock.Elapsed:  REAL;
    VAR now:  ClockValue;
  BEGIN
    GetDateTime (now,mode);
    Elapsed := TimeDiff(now,StartValue)
  END {Clock.Elapsed};

  PROCEDURE Clock.Start (ct:  ClockType);
  BEGIN
    mode := ct;
    GetDateTime (StartValue, ct)
  END {Clock.Start};

  FUNCTION Clock.Time(s:  STRING):  STRING;
  BEGIN
    Time := TimeFormat(s,StartValue)
  END {Time};

END {Clocks}.

{---------------------------  DEMO --------------------------}

PROGRAM ClkDemo;

 {This PROGRAM demonstates how to use the CLOCKS UNIT, including a
  clock object, its methods, and related FUNCTIONs and PROCEDUREs.
  Differences between CMOS and DOS clocks are shown.

  (C) Copyright 1989, Earl F. Glynn, Overland Park, KS.  Compuserve 73257,3527.
  All Rights Reserved.  This Turbo Pascal 5.5 PROGRAM may be freely distributed
  for non-commerical use.

  Several of the examples were derived from "The REXX Language" by
  M.F. Cowlishaw, Prentice Hall, 1985.}

  USES
    CRT,
    Clocks,
    DOS;    {FindFirst,FindNext,SearchRec,AnyFile,DOSError}

  VAR
    Clk1,Clk2,Clk3:  Clock;       {clock objects -- real time clocks}
    stamp1,stamp2 :  ClockValue;  {static clocks -- time stamps}
    stamp3,stamp4 :  ClockValue;
    stamp5        :  ClockValue;
    DirInfo       :  SearchRec;

  PROCEDURE ShowClocks;
  BEGIN
    Clk2.Start (CMOSClock);
    Clk3.Start (DOSClock);
    WRITELN ('  CMOS Clock:  ',Clk2.date('u'),' ',Clk2.time('N') );
    WRITELN ('   DOS Clock:  ',Clk3.date('u'),' ',Clk3.time('L') );
    WRITELN ('  Difference:  ',TimeDiff(Clk2.StartValue,Clk3.StartValue):8:2,
             ' second(s)');
  END {ShowClocks};

  PROCEDURE DisableInterrupts;
    INLINE ($FA);

  PROCEDURE EnableInterrupts;
    INLINE ($FB);

  PROCEDURE KillTime;
    {The following could be used for a 5-second delay, but it re-enables
     interrupts when they are disabled:

        WHILE clk1.elapsed < 5.0 DO (* nothing *);

     So,time will be wasted with a few calculations.}

    VAR
      i:  WORD;
      x:  REAL;
  BEGIN
    WRITELN ('''Kill'' some time ...');
    FOR i := 1 TO 10000 DO
      x := SQRT(i)
  END;

BEGIN
  Clk1.Start (CMOSClock);
  WRITELN ('CMOS/DOS Clock Differences');
  WRITELN ('--------------------------');
  WRITELN ('Start Clocks');
  ShowClocks;
  KillTime;
  ShowClocks;
  WRITELN ('Disable Interrupts (DOS clock will stop):');
  DisableInterrupts;
  KillTime;
  ShowClocks;
  WRITELN ('Enable Interrupts');
  EnableInterrupts;

  SetClock (1985,8,27, 16,54,22, 12, stamp1);  {These are not real-time clocks.}
  SetClock (1900,1, 1,  0, 0, 0,  0, stamp2);
  SetClock (2079,6, 5, 23,59,59, 99, stamp3);

  WRITELN ('Cowlishaw''s':52);
  WRITELN ('now':39,'REXX Book':13,'First':13,'Last':13);
  WRITELN ('Date/DateFormat Examples');
  WRITELN ('------------------------');
  WRITELN ('day this century - C':26,Clk2.Date('Century'):13,
    DateFormat('C',stamp1):13, DateFormat('C',stamp2):13,
    DateFormat('C',stamp3):13);
  WRITELN ('day this year - D':26,   Clk2.Date('Days'):13,
    DateFormat('D',stamp1):13, DateFormat('D',stamp2):13,
    DateFormat('D',stamp3):13);
  WRITELN ('dd/mm/yy - E':26,        Clk2.Date('European'):13,
    DateFormat('E',stamp1):13, DateFormat('E',stamp2):13,
    DateFormat('E',stamp3):13);
  WRITELN ('month name - M':26,      Clk2.Date('MONTH'):13,
    DateFormat('M',stamp1):13, DateFormat('M',stamp2):13,
    DateFormat('M',stamp3):13);
  WRITELN ('dd Mmm yyyy - N':26,     Clk2.Date('normal'):13,
    DateFormat('N',stamp1):13, DateFormat('N',stamp2):13,
    DateFormat('N',stamp3):13);
  WRITELN ('yy/mm/dd - O':26,        Clk2.Date('Ordered'):13,
     DateFormat('O',stamp1):13,DateFormat('O',stamp2):13,
     DateFormat('O',stamp3):13);
  WRITELN ('yyyymmdd - S':26,        Clk2.Date('standard'):13,
    DateFormat('S',stamp1):13, DateFormat('S',stamp2):13,
    DateFormat('S',stamp3):13);
  WRITELN ('mm/dd/yy - U':26,        Clk2.Date('USA'):13,
    DateFormat('U',stamp1):13, DateFormat('U',stamp2):13,
    DateFormat('U',stamp3):13);
  WRITELN ('day of week - W':26,     Clk2.Date('weekday'):13,
    DateFormat('W',stamp1):13, DateFormat('W',stamp2):13,
    DateFormat('W',stamp3):13);

  WRITELN;
  WRITELN ('Time/TimeFormat Examples');
  WRITELN ('------------------------');
  WRITELN ('hh:mmxm - C':26,             Clk2.Time('Civil'):13,
    TimeFormat('C',stamp1):13, TimeFormat('C',stamp2):13,
    TimeFormat('C',stamp3):13);
  WRITELN ('hours since midnight - H':26,Clk2.Time('Hours'):13,
    TimeFormat('h',stamp1):13, TimeFormat('h',stamp2):13,
    TimeFormat('h',stamp3):13);
  WRITELN ('hh:mm:ss.xx - L':26,         Clk2.Time('long'):13,
    TimeFormat('L',stamp1):13, TimeFormat('L',stamp2):13,
    TimeFormat('L',stamp3):13);
  WRITELN ('minutes since midnight - M', Clk2.Time('minutes'):13,
    TimeFormat('m',stamp1):13, TimeFormat('m',stamp2):13,
    TimeFormat('m',stamp3):13);
  WRITELN ('hh:mm:ss - N':26,            Clk2.Time('normal'):13,
    TimeFormat('n',stamp1):13, TimeFormat('n',stamp2):13,
    TimeFormat('n',stamp3):13);
  WRITELN ('seconds since midnight - S', Clk2.Time('seconds'):13,
    TimeFormat('s',stamp1):13, TimeFormat('s',stamp2):13,
    TimeFormat('s',stamp3):13);

  WRITELN;
  WRITELN ('Time Differences/Elapsed Time');
  WRITELN ('-----------------------------');
  WRITELN (' ':20,'seconds':12,'hh:mm:ss':16);
  WRITELN ('CMOS - DOS Clock:':20,
    TimeDiff(Clk2.StartValue,Clk3.StartValue):12:2,
    hhmmss(TimeDiff(Clk2.StartValue,Clk3.StartValue)):16);
  SetClock (1989,1, 1,  0, 0, 0,  0, stamp4);
  SetClock (1990,1, 1,  0, 0, 0,  0, stamp5);
  WRITELN ('Jan 1-Dec 31 1989:':20,TimeDiff(stamp5,stamp4):12:0,
    hhmmss(TimeDiff(stamp5,stamp4)):16);
  WRITELN ('Dec 31-Jan 1 1989:':20,TimeDiff(stamp4,stamp5):12:0,
    hhmmss(TimeDiff(stamp4,stamp5)):16);
  SetClock (1992,1, 1,  0, 0, 0,  0, stamp4);
  SetClock (1993,1, 1,  0, 0, 0,  0, stamp5);
  WRITELN ('1992 (leap year):':20,TimeDiff(stamp5,stamp4):12:0,
    hhmmss(TimeDiff(stamp5,stamp4)):16);
  SetClock (2000,1, 1,  0, 0, 0,  0, stamp5);
  WRITELN ('20th century:':20,TimeDiff(stamp5,stamp2):12:0,
    hhmmss(TimeDiff(stamp5,stamp2)):16,' (100*365 days + 24 leap days)');
  WRITELN ('Maximum Clock Range:':20,TimeDiff(stamp3,stamp2):12:0,
    hhmmss(TimeDiff(stamp3,stamp2)):16,' (January 1, 1900 midnight -');
  WRITELN ('June 5, 2079 23:59:59.99)':78);
  WRITELN ('Elapsed time:':20,Clk1.Elapsed:12:0,
    hhmmss(Clk1.Elapsed):16);

  Readkey;
  WRITELN;
  WRITELN ('Clocks.UnPackTime');
  WRITELN ('-----------------');
  FindFirst ('*.*',AnyFile,DirInfo);
  WHILE DOSError = 0 DO BEGIN  {Note:  seconds on files are even numbers}
    Clocks.UnPackTime (DirInfo.Time, stamp5);
    WRITELN (DirInfo.Name:12,'  ',DirInfo.size:7,'  ',
      COPY(DateFormat('Weekday',stamp5),1,3),' ',
      DateFormat('USA',stamp5),' ',TimeFormat('Normal',stamp5));
    FindNext (DirInfo)
  END;
  Readkey;
END {ClkDemo}.